(define-record-type :regexp-match
  (make-regexp-match str sstart mvec)
  regexp-match?
  (str match:string) (sstart match:search-start) (mvec match:matches))
  
(cond-expand
 (chicken
  (define (posix-string->regexp pstr) (regexp pstr))
  
  (define (regexp-search re str . opt)
    (let-optionals
     opt ((start 0) (flags '()))
     (and-let* ((m (string-search-positions re str start)))
               (make-regexp-match str start (list->vector m)))))  
  )
 (sisc
  (import s2j)
  (import type-system)
  
  (define-java-classes
    (<matcher> |java.util.regex.Matcher|)
    (<pattern> |java.util.regex.Pattern|))
  (define-generic-java-methods
    get-class compile find (jmatcher matcher)
    group-count (mstart start) (mend end))

  (define-syntax :optional
    (syntax-rules ()
      ((:optional rest default-exp)
       (let ((maybe-arg rest))
         (if (pair? maybe-arg)
             (if (null? (cdr maybe-arg)) (car maybe-arg)
                 (error `("too many optional arguments" ,maybe-arg)))
             default-exp)))
      ((:optional rest default-exp arg-test)
       (let ((maybe-arg rest))
         (if (pair? maybe-arg)
             (if (null? (cdr maybe-arg))
                 (let ((val (car maybe-arg)))
                   (if (arg-test val) val
                       (error `("Optional argument failed test"
                                'arg-test ,val))))
                 (error `("too many optional arguments" ,maybe-arg)))
             default-exp)))))
  
  (define (regexp? x) (instance-of? x <pattern>))
  
  (define (posix-string->regexp str)
    (compile (java-null <pattern>) (->jstring str)))
  
  (define (regexp-search re str . opt)
    (define matcher (jmatcher re (->jstring str)))
    (define start 0) (define flags '())
    (if (not (null? opt)) (set! start (car opt)))
    (and-let* ((match? (->boolean (find matcher (->jint start))))
               (cnt (+ 1 (->number (group-count matcher))))
               (matches (make-vector cnt #f)))
              (do ((i 0 (+ i 1))) ((= i cnt) #t)
                (vector-set!
                 matches i (map ->number
                                (map (lambda (f) (f matcher (->jint i)))
                                     (list mstart mend)))))
              (make-regexp-match str start matches)))
  
  ))

(define (match:count m)
  (vector-length (match:matches m)))

(define (match:start m . opt-i)
  (define mi (vector-ref (match:matches m) (:optional opt-i 0)))
  (cond (mi => car) (else #f)))

(define (match:end m . opt-i)
  (define mi (vector-ref (match:matches m) (:optional opt-i 0)))
  (cond (mi => cadr) (else #f)))

(define (regexp-search? . args)
  (if (apply regexp-search args) #t #f))

(define (match:substring m . opt-i)
  (let ((i (:optional opt-i 0)))
    (and-let* ((ms (match:start m i)))
              (substring (match:string m) ms (match:end m i)))))

(define (match:prefix m)
  (substring (match:string m) (match:search-start m) (match:start m)))

(define (match:suffix m)
  (define str (match:string m))
  (substring str (match:end m) (string-length str)))

(define (regexp-for-each re proc str . start)
  (let loop ((start (:optional start 0)))
    (define m (regexp-search re str start))
    (when m
      (proc m)
      (loop (match:end m)))))

(define (regexp-substitute-aux port match onpost items)
  (define res "")
  (define output
    (if port
        (lambda (x) display x port)
        (lambda (x) (set! res (string-append res x)))))
  (define (do-item x)
    (cond
     ((integer? x) (output (match:substring match x)))
     ((string? x) (output x))
     ((procedure? x) (output (x match)))
     ((eq? x 'pre) (output (match:prefix match)))
     ((eq? x 'post) (onpost output))))
  (for-each do-item items)
  (if (not port) res))

(define (regexp-substitute port match . items)
  (define (onpost output)
    (output (match:suffix match)))
  (regexp-substitute-aux port match onpost items))

(define (regexp-substitute/global port re str . items)
  (let loop ((match (regexp-search re str 0)))
    (define (onpost output)
      (define next (regexp-search re str (match:end match)))
      (if next
          (let ((res (loop next)))
            (unless port (output res)))
          (output (match:suffix match))))
    (regexp-substitute-aux port match onpost items)))

(define (regexp-fold re kons knil s . opt)
  (define start 0)
  (define (finish _ x) x)
  (if (not (null? opt))
      (begin
        (set! finish (car opt)) (set! opt (cdr opt))
        (if (not (null? opt)) (set! start (car opt)))))
  (let loop ((i start) (karg knil))
    (define (process-match m)
      (define i2 (match:end m 0))
      (if (= (match:start m) i2)
          (error `(regexp-fold: infinite loop due to empty match in ,s at ,i2 on regexp ,re))
          (loop i2 (kons i m karg))))
    (cond
     ((regexp-search re s i) => process-match)
     (else (finish i karg)))))

(define (regexp-fold-right re kons knil s . opt)
  (define start 0)
  (define (finish _ x) x)
  (define (first-match m)
    (define (loop last)
      (define (process-match m2)
        (let ((i (match:start m2)))
          (if (= i (match:end m2))
              (error `(regexp-fold-right: infinite loop due to empty match in ,s at ,i2 on regexp ,re))
              (kons last i (loop m2)))))
      (cond ((regexp-search re s (match:end last)) => process-match)
            (else (kons last (string-length s) knil))))
    (finish (match:start m) (loop m)))
  (if (not (null? opt))
      (begin
        (set! finish (car opt)) (set! opt (cdr opt))
        (if (not (null? opt)) (set! start (car opt)))))
  (cond ((regexp-search re s start) => first-match)
        (else (finish (string-length s) knil))))
    
                    
              

(define test-cases
  '((let-match
     (begin
       (display "XXX\n")
       (regexp-search (posix-string->regexp "(a|b)(a*)(b*)") "aaabbb"))
     (whole #f fst) (list fst whole))
    (regexp-for-each
     (posix-string->regexp "(a|b)(x*)")
     (lambda (m)
       (let-match m (whole fst snd)
                  (display (list fst snd whole)) (newline)))
     "axbxxabxx")
    ))
